MacWorld UK 2000 March/MW_UK_2000_03.iso/Shareware World/Utilities/Text Processing/Alpha/Tcl/SystemCode/search.tcl

Text File | 1999-10-24 | 19.8 KB | 681 lines | [TEXT/ALFA]

## -*-Tcl-*-
 # ###################################################################
 #  Alpha - new Tcl folder configuration
 #
 #  FILE: "search.tcl"
 #                                    created: 13/6/95 {8:56:37 pm}
 #                                last update: 24/10/1999 {3:26:18 pm}
 #
 # Reorganisation carried out by Vince Darley with much help from Tom
 # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.
 # Alpha is shareware; please register with the author using the register
 # button in the about box.
 #
 #  Description:
 #
 # All procedures which deal with search/reg-search/grep type stuff
 # in Alpha.
 # ###################################################################
 ##

namespace eval text {}
namespace eval quote {}
namespace eval file {}

proc quickFind {} {isearch}
proc reverseQuickFind {} {rsearch}
proc quickFindRegexp {} {regIsearch}

#================================================================================
# 'greplist' and 'grepfset' are used for batch searching from the "find" dialog.
#  Hence, you really shouldn't mess with them unless you know what you are doing.
#================================================================================
proc greplist {args} {
    global tileLeft tileTop tileWidth tileHeight errorHeight

    set recurse [lindex $args 0]
    set word [lindex $args 1]
    set args [lrange $args 2 end]

    set num [expr {[llength $args] - 2}]
    set exp [lindex $args $num]
    set arglist [lindex $args [expr {$num + 1}]]

    set opened 0
    set cid [scancontext create]

    set cmd [lrange $args 0 [expr {$num - 1}]]
    eval scanmatch $cmd {$cid $exp {
    if {!$word || [regexp -nocase -- "(^|\[^a-zA-Z0-9\])${exp}(\[^a-zA-Z0-9\]|\$)" $matchInfo(line)]} {
        if {!$opened} {
        set opened 1
        win::SetProportions
        set w [new -n {* Batch Find *} -m Brws -g $tileLeft $tileTop $tileWidth $errorHeight -tabsize 8]
        insertText "(<cr> to go to match)\r-----\r"
        }
        set l [expr {20 - [string length [file tail $f]]}]
        regsub -all "\t" $matchInfo(line) "  " text
        insertText -w $w "\"[file tail $f]\"[format "%$l\s" ""]; Line $matchInfo(linenum): ${text}\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f\r"}
    }
    }

    foreach f $arglist {
    message [file tail $f]
    if {![catch {set fid [open $f]}]} {
        scanfile $cid $fid
        close $fid
    }
    }
    scancontext delete $cid

    if {$opened} {
    select [nextLineStart [nextLineStart [minPos]]] [nextLineStart [nextLineStart [nextLineStart [minPos]]]]
    setWinInfo dirty 0
    setWinInfo read-only 1
    }
    message ""
}


##
 # -------------------------------------------------------------------------
 #
 # "grepfset" --
 #
 #  args: wordmatch ?-nocase? expression fileset
 #  Obviously we ignore wordmatch
 #
 #  If the 'Grep' box was set, then the search item is _not_ quoted.
 #
 #  Non grep searching problems:
 #
 #  If it wasn't set, then some backslash quoting takes place.
 #  (The chars: \.+*[]$^ are all quoted)
 #  Unfortunately, this latter case is done incorrectly, so most
 #  non-grep searches which contain a grep-sensitive character fail.
 #  The quoting should use the equivalent of the procedure 'quote::Regfind'
 #  but it doesn't quote () and perhaps other important characters.
 #
 #  Even worse, if the string contained any '{' it never reaches this
 #  procedure (there must be an internal error due to bad quoting).
 #
 # -------------------------------------------------------------------------
 ##
proc grepfset {args} {
    set num [expr {[llength $args] - 2}]
    # the 'find' expression
    set exp [lindex $args $num]
    # the fileset
    set fset [lindex $args [expr {$num + 1}]]
    eval greplist 0 [lrange $args 0 [expr {$num-1}]] {$exp [getFileSet $fset]}
}

proc grep {exp args} {
    set files {}
    foreach arg $args {
    eval lappend files [glob -t TEXT -nocomplain -- $arg]
    }
    if {![llength $files]} {return "No files matched pattern"}
    set cid [scancontext create]
    scanmatch $cid $exp {
    if {!$blah} {
        set blah 1
        set lines "(<cr> to go to match)\n"
    }
    set l [expr {20 - [string length [file tail $f]]}]
    regsub -all "\t" $matchInfo(line) "  " text
    append lines "\"[file tail $f]\"[format "%$l\s" ""]; Line $matchInfo(linenum): ${text}\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f\n"
    }

    set blah 0
    set lines ""

    foreach f $files {
    if {![catch {set fid [open $f]}]} {
        message [file tail $f]
        scanfile $cid $fid
        close $fid
    }
    }
    scancontext delete $cid
    return [string trimright $lines "\r"]
}

proc grepnames {exp args} {
    set files {}
    foreach arg $args {
    eval lappend files [glob -t TEXT -nocomplain -- $arg]
    }
    if {![llength $files]} {return "No files matched pattern"}
    set cid [scancontext create]
    scanmatch $cid $exp {
    lappend filenames $f
    }
    set filenames ""
    foreach f $files {
    if {![catch {set fid [open $f]}]} {
        message [file tail $f]
        scanfile $cid $fid
        close $fid
    }
    }
    scancontext delete $cid
    return $filenames
}

##
 # -------------------------------------------------------------------------
 #
 # "performSearch" --
 #
 #  Call this procedure in Tcl code which wants to use the standard procs
 #  like 'replaceAll' to ensure flags like multi-file batch replace are
 #  cleared.  Otherwise replaceAll might not have the desired effect.
 #
 #  This proc is overridden by code (such as supersearch) which might
 #  otherwise cause the nasty behaviour.
 # -------------------------------------------------------------------------
 ##
proc performSearch {args} {
    eval select [uplevel 1 search $args]
}

proc findBatch {forward ignore regexp word pat} {
    matchingLines $pat $forward $ignore $word $regexp
}

##
 # -------------------------------------------------------------------------
 #
 #    "containsSpace"    --
 #
 #     Does the given    text contain any spaces?  In general we    don't complete
 #     commands which    contain    spaces (although perhaps future    extensions
 #     should    do this: e.g. cycle    through    'string    match',    'string    compare',…)
 # -------------------------------------------------------------------------
 ##
proc containsSpace { cmd } { return [string match "*\[ \t\]*" $cmd] }
proc containsReturn { cmd } { return [string match "*\[\r\n\]*" $cmd] }

##
 # -------------------------------------------------------------------------
 #
 #    "findPatJustBefore"    --
 #
 #     Utility proc to check whether the first occurrence    of 'findpat'
 #     to    the    left of    'pos' is actually an occurrence    of 'pat'. It can
 #     be    used to    check if we're part    of an '} else {' (see TclelectricLeft)
 #     or    in TeX mode    if we're in    the    argument of    a '\label{'    or '\ref{'
 #     (see smartScripts)    for    example.
 #
 #     A typical usage has the regexp    'pat' end in '$', so that it must
 #     match all the text    up to 'pos'.  'matchw' can be used to store
 #     the first '()'    pair match in the regexp.
 #
 #     New: maxlook restricts how far this proc will search.  The default
 #     is only 100 (not the entire file), after all this proc is supposed
 #     to look 'just before'!
 # -------------------------------------------------------------------------
 ##
proc findPatJustBefore { findpat pat {pos ""} {matchw ""} {maxlook 100} } {
    if { $pos == "" } {set pos [getPos] }
    if {[pos::compare $pos == [maxPos]]} { set pos [pos::math $pos - 1]}
    if { $matchw != "" } { upvar $matchw word }
    if {[llength [set res [search -s -n -f 0 -r 1 -l [pos::math $pos - $maxlook] -- "$findpat" $pos]]]} {
    if {[regexp -- "$pat" [getText [lindex $res 0] $pos] dum word]} {
        return [lindex $res 0]
    }
    }
    return
}
# Look for pattern in filename after position afterPos and, if found,
# open the file quietly and select the pattern
# author Jonathan Guyer
proc selectPatternInFile {filename pattern {afterPos ""}} {
    if {$afterPos == ""} {set afterPos [minPos]}
    set searchResult [searchInFile $filename $pattern 1]
    if {[pos::compare [lindex $searchResult 0] >= $afterPos]} {
    placeBookmark
    file::openQuietly $filename
    eval select $searchResult
    message "press <Ctl .> to return to original cursor position"
    return 1
    } else {
    return 0
    }
}

proc text::replace {old new {fwd 1} {pos ""}} {
    if {$pos == ""} {set pos [getPos]}
    set m [search -s -f $fwd -m 0 -r 0 -- $old $pos]
    eval replaceText $m [list $new]
}

proc isSelection {} {
    return [pos::compare [getPos] != [selEnd]]
}
proc searchStart {} {
    global search_start
    select [getPos]
    setMark
    if {[catch {goto $search_start}]} {message "No previous search"}
}
set {patternLibrary(Pascal to C Comments)}      { {\{([^\}]*)\}}    {/* \1 */} }
set {patternLibrary(C++ to C Comments)}        { {//(.*)}    {/* \1 */} }
set {patternLibrary(Space Runs to Tabs)}    { { +}    {\t}}

proc getPatternLibrary {} {
    global patternLibrary

    foreach nm [array names patternLibrary] {
    lappend nms [concat [list $nm] $patternLibrary($nm)]
    }
    return $nms
}

# This fails if, say, search string is '\{[^}]'
# This is because the '}' ends the first argument because this
# procedure is presumably called internally with incorrect quoting.
proc rememberPatternHook {search replace} {
    global patternLibrary modifiedArrayElements
    if {[catch {set name [prompt "New pattern's name?" ""]}]} {
    return ""
    }
    lappend modifiedArrayElements [list $name patternLibrary]
    set patternLibrary($name) [list $search $replace]
    return $name
}

proc deletePatternHook {} {
    global patternLibrary modifiedArrayElements
    set temp [list prompt "Delete which pattern?" [lindex [array names patternLibrary] 0] "Pats:"]
    set name [eval [concat $temp [array names patternLibrary]]]
    lappend modifiedArrayElements [list $name patternLibrary]
    unset patternLibrary($name)
}

##
 # -------------------------------------------------------------------------
 #
 # "regIsearch" -- REGular expression Iterative SEARCH
 #
 # This version allows class shorthands (\d \s \w \D \S \W),
 # word anchors (\b), and some aliases of the machine dependent
 # control characters (\a \f \e \n \r \t). Therefore,
 # we need two prompts, one for when we have a valid pattern, and one
 # for when the pattern has gone invalid (most likely due to starting
 # to enter one of the above patterns).
 #
 # The Return key aborts it  and the point goes back to the
 # original $pos. You can then use 'exchangePointAndMark'
 # (cntrl-x, cntrl-x -in emacs keyset) to jump back and forth
 # between where the search started from, to where the search was
 # ended.
 #
 # The Escape key or Mouse-click "exits" it, (as does "abortEm" -bound
 # to cntrl-g), as well as most modifier-key-combinations
 # (except for Shift, and any combination whose  binding's
 # functionality makes sense -see regComp below). Also the
 # up & down Arrow keys, exit it. An exit differs from an abort in that,
 # in the former, the selection is left at the last search result.
 #
 #
 # The next occurrence of the current pattern can be matched by typing
 # either control-s (to get the next occurence forward), or control-r
 # (to get the the next occurrence backward)
 #
 # Also, after aborting, the search string is left in the Find dialog,
 # and so you can use 'findAgain', but, be aware that the Find dialog
 # starts out with a default of <Grep=OFF>.
 #
 # Original Author: Mark Nagata
 # modifications  : Tom Fetherston
 # -------------------------------------------------------------------------
 ##
proc regIsearch {} {

    set ignoreCase 0
    set patt ""
    set pos [getPos]

    set done 0
    while {!$done} {
    # check pattern validatity
    if {[catch {regexp -- $patt {} dmy} dmy]} {
        set prompt "building->: $patt"
    } else {
        set prompt "regIsearch: $patt"
    }
    switch -- [catch {status::prompt $prompt regComp "anything"} res] {
        0 {
        # got a keystroke that triggered a normal end (e.g. <return>)
        goto $pos
        message "Aborted: $patt"
        return
        }
        1 {
        # an error was generated
        if {[string match "missing close-brace" $res]} {
            # must have typed a slash, so:
            append patt "\\"
            continue
        } else {
            # alertnote $res
            set done 1
        }

        }
        default {
        set done 1
        }
    }
    }

    message " Exited: $patt"
}


##
 # -------------------------------------------------------------------------
 #
 # "regComp" -- REGisearch COMmand line input character Processor
 #
 #  This proc handles each keypress while running a regIsearch. It has been
 #  modified from Mark Nagata's original to provide next ocurrence
 #  before/after current, and support for key bindings whose navigation or
 #  text manipulation functionality makes sense with respect to a regIsearch.
 #
 #  closest occurence before current match
 #    - command-option g & cntrl-r (mnemonic 'reverse')
 #  closest occurence after current match
 #    - command g & cntrl-s (mnemonic 'successor')
 #
 #                         Text Naviagation
 #  forwardChar (aborts and leaves cursor after last match)
 #    - right arrow & cntrl-f (emacs)
 #  backwardChar (aborts and leaves cursor before last match)
 #    - left arrow & cntrl-b (emacs)
 #  beginningOfLine (aborts and moves cursors to the start of the line
 #      containing the last match)
 #    - cmd left arrow & cntrl-a (emacs)
 #  beginningOfLine (aborts and moves cursors to the start of the line
 #      containing the last match)
 #    - cmd right arrow & cntrl-e (emacs)
 #
 #                         Text Manipulation
 #  deleteSelection (aborts and deletes selection)
 #    - cntrl-d (emacs)
 #  killLine (aborts and deletes from start of selection to end of line)
 #    - cntrl-k (emacs)
 #
 # -------------------------------------------------------------------------
 ##
proc regComp {curr {key 0} {mod 0}} {
    set direction {}

    # build a string that represents all the modifiers pressed:
    # checking in this order cmd, shift, option, and ctrl
    if {[expr {$mod & 1}]} { append t "c" } else { append t "_" }
    if {[expr {$mod & 34}]} { append t "s" } else { append t "_" }
    if {[expr {$mod & 72}]} { append t "o" } else { append t "_" }
    if {[expr {$mod & 144}]} { append t "z" } else { append t "_" }

    scan $key %c decVal

    switch -- $t {
    "____" {
        switch -- $decVal {
        29 {forwardChar ;         break; # right arrow; }
        28 {backwardChar ;         break; # left arrow; }
        30 {                        break; # up arrow; }
        31 {                        break; # down arrow; }
        }
    }
    }

    switch -- $t {
    "____" -
    "_s__" {
        upvar patt pat
        if {$curr != ""} {
        while {[string compare [string range $pat [string last $curr $pat] end] $curr] != 0} {
            set newEnd [expr {[string length $pat] - 2}]
            if {$newEnd < 0} {
            error "deleted past string start"
            }
            set pat [string range $pat 0 $newEnd]
        }
        }

        set preAppend $pat
        append pat $key
        if {[catch {regexp -- $pat {} dmy} res]} {
        message "building->: $preAppend"
        } else {
        message "regIsearch: $preAppend"
        upvar ignoreCase ign
        set searchResult [search -n -f 1 -m 0 -i $ign -r 1 -- $pat [getPos]]
        if {[llength $searchResult] == 0} {
            beep
        } else {
            select [lindex $searchResult 0] [lindex $searchResult 1]
        }
        }
        return $key

    }
    "c___" {
        switch -- $decVal {
        103 { set direction fwd;        # (cmd g); }
        28 {beginningOfLine ;     break; # cmd left arrow; }
        29 {endOfLine ;         break; # cmd right arrow; }
        }

    }
    "___z" {
        # If the user is using the emacs key bindings, check for ones that
        # make sense. All other control key combinations abort
        if {[package::active emacs]} {
        switch -- $decVal {
            6 {forwardChar ;         break; # cntrl-f; }
            2 {backwardChar ;     break; # cntrl-b; }
            1 {beginningOfLine ;     break; # cntrl-a; }
            5 {endOfLine ;         break; # cntrl-e; }
            4 {deleteSelection ;     break; # cntrl-d; }
            10 {killLine ;         break; # cntrl-k; }
        }
        }
        # See if user has requested to find another match, either searchForward
        # (cntrl-s) or reverseSearch (cntrl-r). Set flag accordingly
        switch -- $decVal {
        115 - 19 { set direction fwd; # (cntrl-s); }
        114 - 18 { set direction bckwd; # (cntrl-r); }
        default {return {} }
        }
    }
    "c_o_" {
        switch -- $decVal {
        169 { set direction bckwd; # (cmd-opt 'g'); }
        default {return {} }
        }

    }
    "default" {
        beep
        error "modifier combination has no meaningful bindings with respect to regIsearch"
    }
    }
    # handle direction flag if it got set above
    if {$direction != ""} {
    upvar patt pat
    upvar ignoreCase ign
    if {[string match $direction fwd]} {
        set dir 1
        set search_start [pos::math [getPos] + 1]
    } else {
        set dir 0
        set search_start [pos::math [getPos] - 1]
    }
    set searchResult [search -n -f $dir -m 0 -i $ign -r 1 -- $pat $search_start]
    if {[llength $searchResult] == 0} {
        beep
    } else {
        select [lindex $searchResult 0] [lindex $searchResult 1]
    }
    return {}
    }
}


proc choicesProc {curr c} {
    global choiceList
    if {$c != "\t"} {return $c}

    set matches {}
    foreach w $choiceList {
    if {[string match "$curr*" $w]} {
        lappend matches $w
    }
    }
    if {![llength $matches]} {
    beep
    } else {
    return [string range [largestPrefix $matches] [string length $curr] end]
    }
    return ""
}


proc sPromptChoices {msg def choiceListIn} {
    global useStatusBar choiceList
    set choiceList $choiceListIn
    if {[catch {statusPrompt -f "$msg ($def): " choicesProc} ans]} {
    error "cancel"
    }
    if {![string length $ans]} {return $def}
    return $ans
}

proc nextFunc {} {
    searchFunc 1
}

proc prevFunc {} {
    searchFunc 0
}

proc jumpNextFunc {} {
    searchFunc 3
}

proc jumpPrevFunc {} {
    searchFunc 2
}

proc searchFunc {code} {
    set pos [getPos]

    #to allow us to handle special cases
    set funcExpr [get_funcExpr $code]

    select $pos

    switch -- $code {
    "1" -
    "3" {
        set pos [pos::math $pos + 1]
        set lastStop [maxPos]
        set dir 1
    }
    "0" -
    "2" {
        set pos [pos::math $pos - 1]
        set lastStop [minPos]
        set dir 0
    }
    }

    if {![catch {search -s -f $dir -i 1 -r 1 -- $funcExpr $pos} res]} {
    eval select $res
    } elseif {$code == 3} {
    searchFunc 1
    } else {
    goto $lastStop
    if {$dir} {
        message "At bottom, no more functions in this direction"
    } else {
        message "At top, no more functions in this direction"
    }
    }
}

proc get_funcExpr {dir} {
    global funcExpr mode
    switch -- $mode {
    "Tcl" {
        if {[regexp "^\\* Trace" [win::CurrentTail]]} {
        switch $dir {
            "0" -
            "1" {
            set searchExpr {(^ *[\w:]+ $)|(^ *[^ ']+ ')}
            }
            "2" {
            if {[regexp {(^.*)OK:} [getSelect] blah searchExpr]} {
                set searchExpr "^${searchExpr}"
            } else {
                set searchExpr {(^ *[\w:]+ $)|(^ *[^ ']+ ')}
            }
            }
            "3" {
            regexp {(^[^']*)'?} [getSelect] blah searchExpr
            set searchExpr "^${searchExpr}OK:"
            }
        }
        } else {
        set searchExpr $funcExpr
        }
    }
    default {
        set searchExpr $funcExpr
    }
    }
    return $searchExpr
}

proc sPrompt {msg def} {
    global useStatusBar
    if {!$useStatusBar} {return [prompt $msg $def]}
    if {[catch {statusPrompt "$msg ($def): "} ans]} {
    error "cancel"
    }
    if {![string length $ans]} {return $def}
    return $ans
}

###
#===========================================================================
# Juan Falgueras (7/Abril/93)
# you only need to select (or not) text and move *forward and backward*
# faster than iSearch (if you have there the |word wo|rd..).
#===========================================================================

proc quickSearch {dir} {
    if {[pos::compare [selEnd] == [getPos]]} {
    backwardChar
    hiliteWord
    }
    set myPos [expr {$dir ? [selEnd] : [pos::math [getPos] - 1]}]
    set text [getSelect]
    set searchResult [search -s -n -f $dir -m 0 -i 1 -r 0 $text $myPos]
    if {[llength $searchResult] == 0} {
    beep
    message [concat [expr {$dir ? "->" : "<-"}] '$text' " not found"]
    return 0
    } else {
    message [concat [expr {$dir ? "->" : "<-"}] '$text']
    eval select $searchResult
    return 1
    }
}